perm filename MFAIL.FAI[XX,LCS]5 blob
sn#227765 filedate 1976-07-22 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 TITLE SMALL
C00010 ENDMK
Cā;
TITLE SMALL
INTERNAL RJBX,CENTX,EXTEN,JDRAW,CENTER,LINX,UNPACK,ROFF
INTERNAL NOZERO,EXCH,BMS,IABS,RHORZ,ABS,RTLINE,FLOAT,IFIX
EXTERNAL .COMM.,STF,POSI,LL,LINES,BM,XRN,PTR,AMOD
EXTERNAL PLTR
;; DEFINE FLOAT(N)
;; < TLC N,232000
;; FADR N,N >
DEFINE FIXX(N)
< KIFIX N,N ā >
RJBX: 0 ;R3=R3+R*RSTJ2
MOVE 2,@(16)
FMPR 2,STF+=8
FADRM 2,.COMM.+=4
JRA 16,1(16)
CENTX: 0 ;CENTX=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
JSA 16,AMOD
JUMP .COMM.+5
JUMP [=100.0] ; -81 TURNS TO 19, 81 TURNS TO -19!!!
CAMGE [-80.0] ;IF(R4.LT.-80)R4=R4+100
FADR [100.0] ; CATCHES R4=-95 ETC.
CAML [80.0] ;IF(R4.GE.80)R4=R4-100
FSBR [100.0] ; CATCHES NEG. MINIS ETC.
MOVEM .COMM.+5 ;[R4=AMOD(R4,100.0)]***********
FMPR [=7.0]
FSBR [=18.0]
FMPR STF+=8
FADR POSI+=9
MOVEM .COMM.+2
JRA 16,(16)
EXTEN: 0 ;FUNCTION EXTEN(X)
HRRM 16,.+2
JSA 16,AMOD ;EXTEN=AMOD(X,1.)*10.
JUMP @0
JUMP [=1.0]
FMPR [=10.0]
JRA 16,1(16)
JDRAW: 0 ;SUBROUTINE JDRAW(M,R3,CENTR,RSTJ2,RX,RY)
;;; MOVE 2,@3(16) ;COMMON/LL/LL
MOVE 13,@4(16) ;DIMENSION M(1)
FMPR 13,@3(16) ;RC=RX*RSTJ2
MOVE 14,@5(16) ;RD=RY*RSTJ2
FMPR 14,@3(16) ;13 HAS RC, 14 HAS RD
MOVE 3,@(16) ;DO 2 K=2,M(1)
HRRZ 12,(16) ; BRING IN ADR. OF M (ZERO LEFT HALF)
MOVE 10,(12) ;PUT ADR. OF M IN 10
ADDI 10,-1(12)
L2: AOJ 12, ; SET UP LOOP
CAILE 12,(10) ; SEE IF WE'VE PASSED END OF LOOP
JRA 16,6(16) ; GO HOME
HRRZM 12,.+4 ; PUT ADR. OF VALUE M(K) IN LAST JUMP
; CALL UNPACK(A,B,M(K))
JSA 16,UNPACK
JUMP 6 ;AA
JUMP 7 ;BB
JUMP
;2 CALL LINES(FLOAT(A)*RC+R3,FLOAT(B)*RD+CENTR,LL)
;; JSA 16,FLOAT
;; JUMP AA
;; MOVE 0,AA
TLC 6,232000
FADR 6,6
FMPR 6,13
FADR 6,@1(16)
;;; MOVEM AA
;; JSA 16,FLOAT
;; JUMP BB
;;; MOVE 0,BB
TLC 7,232000
FADR 7,7
FMPR 7,14
FADR 7,@2(16)
;;; MOVEM BB
JSA 16,LINES
JUMP 6 ;AA
JUMP 7 ;BB
JUMP LL
JRST L2
CENTER: 0 ; SUBROUTINE CENTER(CNTR)
; TO CENTER ITEMS CREATED WITH DRAWING PROG.
; COMMON /STF/RSTFAC(8),RSTJ2
; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
; COMMON/POSI/STF(8),JJ2,POS
; EQUIVALENCE (R4,RJQ(2))
JSA 16,AMOD ;CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ2
JUMP .COMM.+5
JUMP [=100.0]
FMPR [=7.0]
FADR [=2.0]
FMPR STF+=8
FADR POSI+=9
MOVEM @(16)
JRA 16,1(16)
LINX: 0 ; SUBROUTINE LINX(A,B,C,D)
; C SAVES SPACE FOR SINGLE LINES.
MOVE 4,@(16) ;CALL LINES(A,B,3)
MOVE 6,@1(16)
;CALL LINES(C,D,2)
JSA 16,LINES
JUMP 4
JUMP 6
JUMP [=3]
MOVE 6,@2(16)
;; 6 AND 4 ARE FREE IN LINES MOVEM CC
MOVE 4,@3(16)
JSA 16,LINES
JUMP 6
JUMP 4
JUMP [=2]
JRA 16,4(16)
UNPACK: 0 ; SUBROUTINE UNPACK(M,N,I)
; COMMON/LL/L
;C L IS FOR VIS. OR INVIS. LINES.
MOVEI 1,2 ; L=2
MOVE 2,@2(16) ; N=I
MOVE 4,2
IDIV 2,[=100000000] ; M=N/100000000
JUMPE 2,M2 ; IF(M.EQ.0)GO TO 2
AOJ 1, ; L=3
MOVE 4,3 ; N=N-100000000*M
M2: MOVEM 1,LL
IDIVI 4,23420 ;2 M=N/10000
; 5 IS N=MOD(N,10000)
CAIG 4,1750 ; IF(M.GT.1000)M=1000-M
JRST N2
MOVNS 4
ADDI 4,1750
N2: CAIG 5,1750 ; IF(N.GT.1000)N=1000-N
JRST P2
MOVNS 5
ADDI 5,1750
P2: MOVEM 4,@(16)
MOVEM 5,@1(16)
JRA 16,3(16)
ROFF: 0 ; FUNCTION ROFF(R)
MOVSI 200400 ; S=.5
SKIPGE 1,@(16) ; IF(R)S=-S
MOVNS
FADR 1 ; ROFF=R+S
JRA 16,1(16)
NOZERO: 0 ;SUBROUTINE NOZERO(X)
SKIPE @(16) ; IF(X.EQ.0)X=1
JRA 16,1(16)
MOVSI 201400 ; MAKE ALL ZEROS INTO ONES.
MOVEM @(16)
JRA 16,1(16)
EXCH: 0 ; SUBROUTINE EXCH(X,Y)
MOVE @(16)
EXCH 0,@1(16)
MOVEM 0,@(16)
JRA 16,2(16)
BMS: 0 ; SUBROUTINE BMS
MOVE BM+1 ;COMMON/STF/RSTFAC(-3/4),RSTJ2/BM/RA,RC,RKY
FMPR STF+=8 ; CALL LINES(RA,RJY+RC*RSTJ2,2)
FADR BM+2
MOVEM CENTX
JSA 16,LINES ; END
JUMP BM
JUMP CENTX
JUMP [2]
JRA 16,(16)
ABS: 0
JRST .+2
IABS: 0 ; FUNCTION IABS(N)
MOVM 0,@(16) ;BECAUSE IABS IN LIB40 HAS A BUG.
JRA 16,1(16) ; IABS=N ; IF(N)IABS=-N
RHORZ: 0 ; FUNCTION RHORZ(R)
MOVE @(16) ; RHORZ=R*5.96-596.
FMPR [=5.96]
FSBR [=596.0]
JRA 16,1(16)
RTLINE: 0 ;FUNCTION RTLINE(L)
MOVE 2,.COMM. ;COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
CAMLE 2,[=4.0] ;RTLINE=-1
JRST ZRO ;IF(R2.GT.4)GO TO 1
;; HRRZ @(16) ;IF(RN(L+2).NE.R2)RETURN
MOVE 3,@(16)
;; HRRZI 3,XRN ; PUT ADR. OF XRN IN 3
;; ADD 3, ; 1 RTLINE=0
SETO
CAMN 2,XRN+1(3)
ZRO: SETZ
JRA 16,1(16)
FLOAT: 0
MOVE 0,@(16)
TLC 0,232000
FADR 0,0
JRA 16,1(16)
IFIX: 0
MOVE 0,@(16)
JUMPGE 0,.+5
MOVNS 0
KAFIX 0,233000
MOVNS 0
CAIA
KAFIX 0,233000
JRA 16,1(16)
END